home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Pod / Simple / BlackBox.pm next >
Encoding:
Perl POD Document  |  2009-06-26  |  61.1 KB  |  1,924 lines
  1.  
  2. package Pod::Simple::BlackBox;
  3. #
  4. # "What's in the box?"  "Pain."
  5. #
  6. ###########################################################################
  7. #
  8. # This is where all the scary things happen: parsing lines into
  9. #  paragraphs; and then into directives, verbatims, and then also
  10. #  turning formatting sequences into treelets.
  11. #
  12. # Are you really sure you want to read this code?
  13. #
  14. #-----------------------------------------------------------------------------
  15. #
  16. # The basic work of this module Pod::Simple::BlackBox is doing the dirty work
  17. # of parsing Pod into treelets (generally one per non-verbatim paragraph), and
  18. # to call the proper callbacks on the treelets.
  19. #
  20. # Every node in a treelet is a ['name', {attrhash}, ...children...]
  21.  
  22. use integer; # vroom!
  23. use strict;
  24. use Carp ();
  25. BEGIN {
  26.   require Pod::Simple;
  27.   *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG
  28. }
  29.  
  30. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  31.  
  32. sub parse_line { shift->parse_lines(@_) } # alias
  33.  
  34. # - - -  Turn back now!  Run away!  - - -
  35.  
  36. sub parse_lines {             # Usage: $parser->parse_lines(@lines)
  37.   # an undef means end-of-stream
  38.   my $self = shift;
  39.  
  40.   my $code_handler = $self->{'code_handler'};
  41.   my $cut_handler  = $self->{'cut_handler'};
  42.   $self->{'line_count'} ||= 0;
  43.  
  44.   my $scratch;
  45.  
  46.   DEBUG > 4 and 
  47.    print "# Parsing starting at line ", $self->{'line_count'}, ".\n";
  48.  
  49.   DEBUG > 5 and
  50.    print "#  About to parse lines: ",
  51.      join(' ', map defined($_) ? "[$_]" : "EOF", @_), "\n";
  52.  
  53.   my $paras = ($self->{'paras'} ||= []);
  54.    # paragraph buffer.  Because we need to defer processing of =over
  55.    # directives and verbatim paragraphs.  We call _ponder_paragraph_buffer
  56.    # to process this.
  57.   
  58.   $self->{'pod_para_count'} ||= 0;
  59.  
  60.   my $line;
  61.   foreach my $source_line (@_) {
  62.     if( $self->{'source_dead'} ) {
  63.       DEBUG > 4 and print "# Source is dead.\n";
  64.       last;
  65.     }
  66.  
  67.     unless( defined $source_line ) {
  68.       DEBUG > 4 and print "# Undef-line seen.\n";
  69.  
  70.       push @$paras, ['~end', {'start_line' => $self->{'line_count'}}];
  71.       push @$paras, $paras->[-1], $paras->[-1];
  72.        # So that it definitely fills the buffer.
  73.       $self->{'source_dead'} = 1;
  74.       $self->_ponder_paragraph_buffer;
  75.       next;
  76.     }
  77.  
  78.  
  79.     if( $self->{'line_count'}++ ) {
  80.       ($line = $source_line) =~ tr/\n\r//d;
  81.        # If we don't have two vars, we'll end up with that there
  82.        # tr/// modding the (potentially read-only) original source line!
  83.     
  84.     } else {
  85.       DEBUG > 2 and print "First line: [$source_line]\n";
  86.  
  87.       if( ($line = $source_line) =~ s/^\xEF\xBB\xBF//s ) {
  88.         DEBUG and print "UTF-8 BOM seen.  Faking a '=encode utf8'.\n";
  89.         $self->_handle_encoding_line( "=encode utf8" );
  90.         $line =~ tr/\n\r//d;
  91.         
  92.       } elsif( $line =~ s/^\xFE\xFF//s ) {
  93.         DEBUG and print "Big-endian UTF-16 BOM seen.  Aborting parsing.\n";
  94.         $self->scream(
  95.           $self->{'line_count'},
  96.           "UTF16-BE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet."
  97.         );
  98.         splice @_;
  99.         push @_, undef;
  100.         next;
  101.  
  102.         # TODO: implement somehow?
  103.  
  104.       } elsif( $line =~ s/^\xFF\xFE//s ) {
  105.         DEBUG and print "Little-endian UTF-16 BOM seen.  Aborting parsing.\n";
  106.         $self->scream(
  107.           $self->{'line_count'},
  108.           "UTF16-LE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet."
  109.         );
  110.         splice @_;
  111.         push @_, undef;
  112.         next;
  113.  
  114.         # TODO: implement somehow?
  115.         
  116.       } else {
  117.         DEBUG > 2 and print "First line is BOM-less.\n";
  118.         ($line = $source_line) =~ tr/\n\r//d;
  119.       }
  120.     }
  121.  
  122.  
  123.     DEBUG > 5 and print "# Parsing line: [$line]\n";
  124.  
  125.     if(!$self->{'in_pod'}) {
  126.       if($line =~ m/^=([a-zA-Z]+)/s) {
  127.         if($1 eq 'cut') {
  128.           $self->scream(
  129.             $self->{'line_count'},
  130.             "=cut found outside a pod block.  Skipping to next block."
  131.           );
  132.           
  133.           ## Before there were errata sections in the world, it was
  134.           ## least-pessimal to abort processing the file.  But now we can
  135.           ## just barrel on thru (but still not start a pod block).
  136.           #splice @_;
  137.           #push @_, undef;
  138.           
  139.           next;
  140.         } else {
  141.           $self->{'in_pod'} = $self->{'start_of_pod_block'}
  142.                             = $self->{'last_was_blank'}     = 1;
  143.           # And fall thru to the pod-mode block further down
  144.         }
  145.       } else {
  146.         DEBUG > 5 and print "# It's a code-line.\n";
  147.         $code_handler->(map $_, $line, $self->{'line_count'}, $self)
  148.          if $code_handler;
  149.         # Note: this may cause code to be processed out of order relative
  150.         #  to pods, but in order relative to cuts.
  151.         
  152.         # Note also that we haven't yet applied the transcoding to $line
  153.         #  by time we call $code_handler!
  154.  
  155.         if( $line =~ m/^#\s*line\s+(\d+)\s*(?:\s"([^"]+)")?\s*$/ ) {
  156.           # That RE is from perlsyn, section "Plain Old Comments (Not!)",
  157.           #$fname = $2 if defined $2;
  158.           #DEBUG > 1 and defined $2 and print "# Setting fname to \"$fname\"\n";
  159.           DEBUG > 1 and print "# Setting nextline to $1\n";
  160.           $self->{'line_count'} = $1 - 1;
  161.         }
  162.         
  163.         next;
  164.       }
  165.     }
  166.     
  167.     # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  168.     # Else we're in pod mode:
  169.  
  170.     # Apply any necessary transcoding:
  171.     $self->{'_transcoder'} && $self->{'_transcoder'}->($line);
  172.  
  173.     # HERE WE CATCH =encoding EARLY!
  174.     if( $line =~ m/^=encoding\s+\S+\s*$/s ) {
  175.       $line = $self->_handle_encoding_line( $line );
  176.     }
  177.  
  178.     if($line =~ m/^=cut/s) {
  179.       # here ends the pod block, and therefore the previous pod para
  180.       DEBUG > 1 and print "Noting =cut at line ${$self}{'line_count'}\n";
  181.       $self->{'in_pod'} = 0;
  182.       # ++$self->{'pod_para_count'};
  183.       $self->_ponder_paragraph_buffer();
  184.        # by now it's safe to consider the previous paragraph as done.
  185.       $cut_handler->(map $_, $line, $self->{'line_count'}, $self)
  186.        if $cut_handler;
  187.  
  188.       # TODO: add to docs: Note: this may cause cuts to be processed out
  189.       #  of order relative to pods, but in order relative to code.
  190.       
  191.     } elsif($line =~ m/^\s*$/s) {  # it's a blank line
  192.       if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
  193.         DEBUG > 1 and print "Saving blank line at line ${$self}{'line_count'}\n";
  194.         push @{$paras->[-1]}, $line;
  195.       }  # otherwise it's not interesting
  196.       
  197.       if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) {
  198.         DEBUG > 1 and print "Noting para ends with blank line at ${$self}{'line_count'}\n"; 
  199.       }
  200.       
  201.       $self->{'last_was_blank'} = 1;
  202.       
  203.     } elsif($self->{'last_was_blank'}) {  # A non-blank line starting a new para...
  204.       
  205.       if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(?:\s+|$)(.*)/s) {
  206.         # THIS IS THE ONE PLACE WHERE WE CONSTRUCT NEW DIRECTIVE OBJECTS
  207.         my $new = [$1, {'start_line' => $self->{'line_count'}}, $2];
  208.          # Note that in "=head1 foo", the WS is lost.
  209.          # Example: ['=head1', {'start_line' => 123}, ' foo']
  210.         
  211.         ++$self->{'pod_para_count'};
  212.         
  213.         $self->_ponder_paragraph_buffer();
  214.          # by now it's safe to consider the previous paragraph as done.
  215.                 
  216.         push @$paras, $new; # the new incipient paragraph
  217.         DEBUG > 1 and print "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n";
  218.         
  219.       } elsif($line =~ m/^\s/s) {
  220.  
  221.         if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
  222.           DEBUG > 1 and print "Resuming verbatim para at line ${$self}{'line_count'}\n";
  223.           push @{$paras->[-1]}, $line;
  224.         } else {
  225.           ++$self->{'pod_para_count'};
  226.           $self->_ponder_paragraph_buffer();
  227.            # by now it's safe to consider the previous paragraph as done.
  228.           DEBUG > 1 and print "Starting verbatim para at line ${$self}{'line_count'}\n";
  229.           push @$paras, ['~Verbatim', {'start_line' => $self->{'line_count'}}, $line];
  230.         }
  231.       } else {
  232.         ++$self->{'pod_para_count'};
  233.         $self->_ponder_paragraph_buffer();
  234.          # by now it's safe to consider the previous paragraph as done.
  235.         push @$paras, ['~Para',  {'start_line' => $self->{'line_count'}}, $line];
  236.         DEBUG > 1 and print "Starting plain para at line ${$self}{'line_count'}\n";
  237.       }
  238.       $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0;
  239.  
  240.     } else {
  241.       # It's a non-blank line /continuing/ the current para
  242.       if(@$paras) {
  243.         DEBUG > 2 and print "Line ${$self}{'line_count'} continues current paragraph\n";
  244.         push @{$paras->[-1]}, $line;
  245.       } else {
  246.         # Unexpected case!
  247.         die "Continuing a paragraph but \@\$paras is empty?";
  248.       }
  249.       $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0;
  250.     }
  251.     
  252.   } # ends the big while loop
  253.  
  254.   DEBUG > 1 and print(pretty(@$paras), "\n");
  255.   return $self;
  256. }
  257.  
  258. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  259.  
  260. sub _handle_encoding_line {
  261.   my($self, $line) = @_;
  262.   
  263.   # The point of this routine is to set $self->{'_transcoder'} as indicated.
  264.  
  265.   return $line unless $line =~ m/^=encoding\s+(\S+)\s*$/s;
  266.   DEBUG > 1 and print "Found an encoding line \"=encoding $1\"\n";
  267.  
  268.   my $e    = $1;
  269.   my $orig = $e;
  270.   push @{ $self->{'encoding_command_reqs'} }, "=encoding $orig";
  271.  
  272.   my $enc_error;
  273.  
  274.   # Cf.   perldoc Encode   and   perldoc Encode::Supported
  275.  
  276.   require Pod::Simple::Transcode;
  277.  
  278.   if( $self->{'encoding'} ) {
  279.     my $norm_current = $self->{'encoding'};
  280.     my $norm_e = $e;
  281.     foreach my $that ($norm_current, $norm_e) {
  282.       $that =  lc($that);
  283.       $that =~ s/[-_]//g;
  284.     }
  285.     if($norm_current eq $norm_e) {
  286.       DEBUG > 1 and print "The '=encoding $orig' line is ",
  287.        "redundant.  ($norm_current eq $norm_e).  Ignoring.\n";
  288.       $enc_error = '';
  289.        # But that doesn't necessarily mean that the earlier one went okay
  290.     } else {
  291.       $enc_error = "Encoding is already set to " . $self->{'encoding'};
  292.       DEBUG > 1 and print $enc_error;
  293.     }
  294.   } elsif (
  295.     # OK, let's turn on the encoding
  296.     do {
  297.       DEBUG > 1 and print " Setting encoding to $e\n";
  298.       $self->{'encoding'} = $e;
  299.       1;
  300.     }
  301.     and $e eq 'HACKRAW'
  302.   ) {
  303.     DEBUG and print " Putting in HACKRAW (no-op) encoding mode.\n";
  304.  
  305.   } elsif( Pod::Simple::Transcode::->encoding_is_available($e) ) {
  306.  
  307.     die($enc_error = "WHAT? _transcoder is already set?!")
  308.      if $self->{'_transcoder'};   # should never happen
  309.     require Pod::Simple::Transcode;
  310.     $self->{'_transcoder'} = Pod::Simple::Transcode::->make_transcoder($e);
  311.     eval {
  312.       my @x = ('', "abc", "123");
  313.       $self->{'_transcoder'}->(@x);
  314.     };
  315.     $@ && die( $enc_error =
  316.       "Really unexpected error setting up encoding $e: $@\nAborting"
  317.     );
  318.  
  319.   } else {
  320.     my @supported = Pod::Simple::Transcode::->all_encodings;
  321.  
  322.     # Note unsupported, and complain
  323.     DEBUG and print " Encoding [$e] is unsupported.",
  324.       "\nSupporteds: @supported\n";
  325.     my $suggestion = '';
  326.  
  327.     # Look for a near match:
  328.     my $norm = lc($e);
  329.     $norm =~ tr[-_][]d;
  330.     my $n;
  331.     foreach my $enc (@supported) {
  332.       $n = lc($enc);
  333.       $n =~ tr[-_][]d;
  334.       next unless $n eq $norm;
  335.       $suggestion = "  (Maybe \"$e\" should be \"$enc\"?)";
  336.       last;
  337.     }
  338.     my $encmodver = Pod::Simple::Transcode::->encmodver;
  339.     $enc_error = join '' =>
  340.       "This document probably does not appear as it should, because its ",
  341.       "\"=encoding $e\" line calls for an unsupported encoding.",
  342.       $suggestion, "  [$encmodver\'s supported encodings are: @supported]"
  343.     ;
  344.  
  345.     $self->scream( $self->{'line_count'}, $enc_error );
  346.   }
  347.   push @{ $self->{'encoding_command_statuses'} }, $enc_error;
  348.  
  349.   return '=encoding ALREADYDONE';
  350. }
  351.  
  352. # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  353.  
  354. sub _handle_encoding_second_level {
  355.   # By time this is called, the encoding (if well formed) will already
  356.   #  have been acted one.
  357.   my($self, $para) = @_;
  358.   my @x = @$para;
  359.   my $content = join ' ', splice @x, 2;
  360.   $content =~ s/^\s+//s;
  361.   $content =~ s/\s+$//s;
  362.  
  363.   DEBUG > 2 and print "Ogling encoding directive: =encoding $content\n";
  364.   
  365.   if($content eq 'ALREADYDONE') {
  366.     # It's already been handled.  Check for errors.
  367.     if(! $self->{'encoding_command_statuses'} ) {
  368.       DEBUG > 2 and print " CRAZY ERROR: It wasn't really handled?!\n";
  369.     } elsif( $self->{'encoding_command_statuses'}[-1] ) {
  370.       $self->whine( $para->[1]{'start_line'},
  371.         sprintf "Couldn't do %s: %s",
  372.           $self->{'encoding_command_reqs'  }[-1],
  373.           $self->{'encoding_command_statuses'}[-1],
  374.       );
  375.     } else {
  376.       DEBUG > 2 and print " (Yup, it was successfully handled already.)\n";
  377.     }
  378.     
  379.   } else {
  380.     # Otherwise it's a syntax error
  381.     $self->whine( $para->[1]{'start_line'},
  382.       "Invalid =encoding syntax: $content"
  383.     );
  384.   }
  385.   
  386.   return;
  387. }
  388.  
  389. #~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`
  390.  
  391. {
  392. my $m = -321;   # magic line number
  393.  
  394. sub _gen_errata {
  395.   my $self = $_[0];
  396.   # Return 0 or more fake-o paragraphs explaining the accumulated
  397.   #  errors on this document.
  398.  
  399.   return() unless $self->{'errata'} and keys %{$self->{'errata'}};
  400.  
  401.   my @out;
  402.   
  403.   foreach my $line (sort {$a <=> $b} keys %{$self->{'errata'}}) {
  404.     push @out,
  405.       ['=item', {'start_line' => $m}, "Around line $line:"],
  406.       map( ['~Para', {'start_line' => $m, '~cooked' => 1},
  407.         #['~Top', {'start_line' => $m},
  408.         $_
  409.         #]
  410.         ],
  411.         @{$self->{'errata'}{$line}}
  412.       )
  413.     ;
  414.   }
  415.   
  416.   # TODO: report of unknown entities? unrenderable characters?
  417.  
  418.   unshift @out,
  419.     ['=head1', {'start_line' => $m, 'errata' => 1}, 'POD ERRORS'],
  420.     ['~Para', {'start_line' => $m, '~cooked' => 1, 'errata' => 1},
  421.      "Hey! ",
  422.      ['B', {},
  423.       'The above document had some coding errors, which are explained below:'
  424.      ]
  425.     ],
  426.     ['=over',  {'start_line' => $m, 'errata' => 1}, ''],
  427.   ;
  428.  
  429.   push @out, 
  430.     ['=back',  {'start_line' => $m, 'errata' => 1}, ''],
  431.   ;
  432.  
  433.   DEBUG and print "\n<<\n", pretty(\@out), "\n>>\n\n";
  434.  
  435.   return @out;
  436. }
  437.  
  438. }
  439.  
  440. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  441.  
  442. ##############################################################################
  443. ##
  444. ##  stop reading now stop reading now stop reading now stop reading now stop
  445. ##
  446. ##                         HERE IT BECOMES REALLY SCARY
  447. ##
  448. ##  stop reading now stop reading now stop reading now stop reading now stop
  449. ##
  450. ##############################################################################
  451.  
  452. sub _ponder_paragraph_buffer {
  453.  
  454.   # Para-token types as found in the buffer.
  455.   #   ~Verbatim, ~Para, ~end, =head1..4, =for, =begin, =end,
  456.   #   =over, =back, =item
  457.   #   and the null =pod (to be complained about if over one line)
  458.   #
  459.   # "~data" paragraphs are something we generate at this level, depending on
  460.   # a currently open =over region
  461.  
  462.   # Events fired:  Begin and end for:
  463.   #                   directivename (like head1 .. head4), item, extend,
  464.   #                   for (from =begin...=end, =for),
  465.   #                   over-bullet, over-number, over-text, over-block,
  466.   #                   item-bullet, item-number, item-text,
  467.   #                   Document,
  468.   #                   Data, Para, Verbatim
  469.   #                   B, C, longdirname (TODO -- wha?), etc. for all directives
  470.   # 
  471.  
  472.   my $self = $_[0];
  473.   my $paras;
  474.   return unless @{$paras = $self->{'paras'}};
  475.   my $curr_open = ($self->{'curr_open'} ||= []);
  476.  
  477.   my $scratch;
  478.  
  479.   DEBUG > 10 and print "# Paragraph buffer: <<", pretty($paras), ">>\n";
  480.  
  481.   # We have something in our buffer.  So apparently the document has started.
  482.   unless($self->{'doc_has_started'}) {
  483.     $self->{'doc_has_started'} = 1;
  484.     
  485.     my $starting_contentless;
  486.     $starting_contentless =
  487.      (
  488.        !@$curr_open  
  489.        and @$paras and ! grep $_->[0] ne '~end', @$paras
  490.         # i.e., if the paras is all ~ends
  491.      )
  492.     ;
  493.     DEBUG and print "# Starting ", 
  494.       $starting_contentless ? 'contentless' : 'contentful',
  495.       " document\n"
  496.     ;
  497.     
  498.     $self->_handle_element_start(
  499.       ($scratch = 'Document'),
  500.       {
  501.         'start_line' => $paras->[0][1]{'start_line'},
  502.         $starting_contentless ? ( 'contentless' => 1 ) : (),
  503.       },
  504.     );
  505.   }
  506.  
  507.   my($para, $para_type);
  508.   while(@$paras) {
  509.     last if @$paras == 1 and
  510.       ( $paras->[0][0] eq '=over' or $paras->[0][0] eq '~Verbatim'
  511.         or $paras->[0][0] eq '=item' )
  512.     ;
  513.     # Those're the three kinds of paragraphs that require lookahead.
  514.     #   Actually, an "=item Foo" inside an <over type=text> region
  515.     #   and any =item inside an <over type=block> region (rare)
  516.     #   don't require any lookahead, but all others (bullets
  517.     #   and numbers) do.
  518.  
  519. # TODO: winge about many kinds of directives in non-resolving =for regions?
  520. # TODO: many?  like what?  =head1 etc?
  521.  
  522.     $para = shift @$paras;
  523.     $para_type = $para->[0];
  524.  
  525.     DEBUG > 1 and print "Pondering a $para_type paragraph, given the stack: (",
  526.       $self->_dump_curr_open(), ")\n";
  527.     
  528.     if($para_type eq '=for') {
  529.       next if $self->_ponder_for($para,$curr_open,$paras);
  530.  
  531.     } elsif($para_type eq '=begin') {
  532.       next if $self->_ponder_begin($para,$curr_open,$paras);
  533.  
  534.     } elsif($para_type eq '=end') {
  535.       next if $self->_ponder_end($para,$curr_open,$paras);
  536.  
  537.     } elsif($para_type eq '~end') { # The virtual end-document signal
  538.       next if $self->_ponder_doc_end($para,$curr_open,$paras);
  539.     }
  540.  
  541.  
  542.     # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
  543.     #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
  544.     if(grep $_->[1]{'~ignore'}, @$curr_open) {
  545.       DEBUG > 1 and
  546.        print "Skipping $para_type paragraph because in ignore mode.\n";
  547.       next;
  548.     }
  549.     #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
  550.     # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
  551.  
  552.     if($para_type eq '=pod') {
  553.       $self->_ponder_pod($para,$curr_open,$paras);
  554.  
  555.     } elsif($para_type eq '=over') {
  556.       next if $self->_ponder_over($para,$curr_open,$paras);
  557.  
  558.     } elsif($para_type eq '=back') {
  559.       next if $self->_ponder_back($para,$curr_open,$paras);
  560.  
  561.     } else {
  562.  
  563.       # All non-magical codes!!!
  564.       
  565.       # Here we start using $para_type for our own twisted purposes, to
  566.       #  mean how it should get treated, not as what the element name
  567.       #  should be.
  568.  
  569.       DEBUG > 1 and print "Pondering non-magical $para_type\n";
  570.  
  571.       my $i;
  572.  
  573.       # Enforce some =headN discipline
  574.       if($para_type =~ m/^=head\d$/s
  575.          and ! $self->{'accept_heads_anywhere'}
  576.          and @$curr_open
  577.          and $curr_open->[-1][0] eq '=over'
  578.       ) {
  579.         DEBUG > 2 and print "'=$para_type' inside an '=over'!\n";
  580.         $self->whine(
  581.           $para->[1]{'start_line'},
  582.           "You forgot a '=back' before '$para_type'"
  583.         );
  584.         unshift @$paras, ['=back', {}, ''], $para;   # close the =over
  585.         next;
  586.       }
  587.  
  588.  
  589.       if($para_type eq '=item') {
  590.  
  591.         my $over;
  592.         unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') {
  593.           $self->whine(
  594.             $para->[1]{'start_line'},
  595.             "'=item' outside of any '=over'"
  596.           );
  597.           unshift @$paras,
  598.             ['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
  599.             $para
  600.           ;
  601.           next;
  602.         }
  603.         
  604.         
  605.         my $over_type = $over->[1]{'~type'};
  606.         
  607.         if(!$over_type) {
  608.           # Shouldn't happen1
  609.           die "Typeless over in stack, starting at line "
  610.            . $over->[1]{'start_line'};
  611.  
  612.         } elsif($over_type eq 'block') {
  613.           unless($curr_open->[-1][1]{'~bitched_about'}) {
  614.             $curr_open->[-1][1]{'~bitched_about'} = 1;
  615.             $self->whine(
  616.               $curr_open->[-1][1]{'start_line'},
  617.               "You can't have =items (as at line "
  618.               . $para->[1]{'start_line'}
  619.               . ") unless the first thing after the =over is an =item"
  620.             );
  621.           }
  622.           # Just turn it into a paragraph and reconsider it
  623.           $para->[0] = '~Para';
  624.           unshift @$paras, $para;
  625.           next;
  626.  
  627.         } elsif($over_type eq 'text') {
  628.           my $item_type = $self->_get_item_type($para);
  629.             # That kills the content of the item if it's a number or bullet.
  630.           DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
  631.           
  632.           if($item_type eq 'text') {
  633.             # Nothing special needs doing for 'text'
  634.           } elsif($item_type eq 'number' or $item_type eq 'bullet') {
  635.             die "Unknown item type $item_type"
  636.              unless $item_type eq 'number' or $item_type eq 'bullet';
  637.             # Undo our clobbering:
  638.             push @$para, $para->[1]{'~orig_content'};
  639.             delete $para->[1]{'number'};
  640.              # Only a PROPER item-number element is allowed
  641.              #  to have a number attribute.
  642.           } else {
  643.             die "Unhandled item type $item_type"; # should never happen
  644.           }
  645.           
  646.           # =item-text thingies don't need any assimilation, it seems.
  647.  
  648.         } elsif($over_type eq 'number') {
  649.           my $item_type = $self->_get_item_type($para);
  650.             # That kills the content of the item if it's a number or bullet.
  651.           DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
  652.           
  653.           my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
  654.           
  655.           if($item_type eq 'bullet') {
  656.             # Hm, it's not numeric.  Correct for this.
  657.             $para->[1]{'number'} = $expected_value;
  658.             $self->whine(
  659.               $para->[1]{'start_line'},
  660.               "Expected '=item $expected_value'"
  661.             );
  662.             push @$para, $para->[1]{'~orig_content'};
  663.               # restore the bullet, blocking the assimilation of next para
  664.  
  665.           } elsif($item_type eq 'text') {
  666.             # Hm, it's not numeric.  Correct for this.
  667.             $para->[1]{'number'} = $expected_value;
  668.             $self->whine(
  669.               $para->[1]{'start_line'},
  670.               "Expected '=item $expected_value'"
  671.             );
  672.             # Text content will still be there and will block next ~Para
  673.  
  674.           } elsif($item_type ne 'number') {
  675.             die "Unknown item type $item_type"; # should never happen
  676.  
  677.           } elsif($expected_value == $para->[1]{'number'}) {
  678.             DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n";
  679.             
  680.           } else {
  681.             DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'},
  682.              " instead of the expected value of $expected_value\n";
  683.             $self->whine(
  684.               $para->[1]{'start_line'},
  685.               "You have '=item " . $para->[1]{'number'} .
  686.               "' instead of the expected '=item $expected_value'"
  687.             );
  688.             $para->[1]{'number'} = $expected_value;  # correcting!!
  689.           }
  690.             
  691.           if(@$para == 2) {
  692.             # For the cases where we /didn't/ push to @$para
  693.             if($paras->[0][0] eq '~Para') {
  694.               DEBUG and print "Assimilating following ~Para content into $over_type item\n";
  695.               push @$para, splice @{shift @$paras},2;
  696.             } else {
  697.               DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
  698.               push @$para, '';  # Just so it's not contentless
  699.             }
  700.           }
  701.  
  702.  
  703.         } elsif($over_type eq 'bullet') {
  704.           my $item_type = $self->_get_item_type($para);
  705.             # That kills the content of the item if it's a number or bullet.
  706.           DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
  707.           
  708.           if($item_type eq 'bullet') {
  709.             # as expected!
  710.  
  711.             if( $para->[1]{'~_freaky_para_hack'} ) {
  712.               DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n";
  713.               push @$para, delete $para->[1]{'~_freaky_para_hack'};
  714.             }
  715.  
  716.           } elsif($item_type eq 'number') {
  717.             $self->whine(
  718.               $para->[1]{'start_line'},
  719.               "Expected '=item *'"
  720.             );
  721.             push @$para, $para->[1]{'~orig_content'};
  722.              # and block assimilation of the next paragraph
  723.             delete $para->[1]{'number'};
  724.              # Only a PROPER item-number element is allowed
  725.              #  to have a number attribute.
  726.           } elsif($item_type eq 'text') {
  727.             $self->whine(
  728.               $para->[1]{'start_line'},
  729.               "Expected '=item *'"
  730.             );
  731.              # But doesn't need processing.  But it'll block assimilation
  732.              #  of the next para.
  733.           } else {
  734.             die "Unhandled item type $item_type"; # should never happen
  735.           }
  736.  
  737.           if(@$para == 2) {
  738.             # For the cases where we /didn't/ push to @$para
  739.             if($paras->[0][0] eq '~Para') {
  740.               DEBUG and print "Assimilating following ~Para content into $over_type item\n";
  741.               push @$para, splice @{shift @$paras},2;
  742.             } else {
  743.               DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
  744.               push @$para, '';  # Just so it's not contentless
  745.             }
  746.           }
  747.  
  748.         } else {
  749.           die "Unhandled =over type \"$over_type\"?";
  750.           # Shouldn't happen!
  751.         }
  752.  
  753.         $para_type = 'Plain';
  754.         $para->[0] .= '-' . $over_type;
  755.         # Whew.  Now fall thru and process it.
  756.  
  757.  
  758.       } elsif($para_type eq '=extend') {
  759.         # Well, might as well implement it here.
  760.         $self->_ponder_extend($para);
  761.         next;  # and skip
  762.       } elsif($para_type eq '=encoding') {
  763.         # Not actually acted on here, but we catch errors here.
  764.         $self->_handle_encoding_second_level($para);
  765.  
  766.         next;  # and skip
  767.       } elsif($para_type eq '~Verbatim') {
  768.         $para->[0] = 'Verbatim';
  769.         $para_type = '?Verbatim';
  770.       } elsif($para_type eq '~Para') {
  771.         $para->[0] = 'Para';
  772.         $para_type = '?Plain';
  773.       } elsif($para_type eq 'Data') {
  774.         $para->[0] = 'Data';
  775.         $para_type = '?Data';
  776.       } elsif( $para_type =~ s/^=//s
  777.         and defined( $para_type = $self->{'accept_directives'}{$para_type} )
  778.       ) {
  779.         DEBUG > 1 and print " Pondering known directive ${$para}[0] as $para_type\n";
  780.       } else {
  781.         # An unknown directive!
  782.         DEBUG > 1 and printf "Unhandled directive %s (Handled: %s)\n",
  783.          $para->[0], join(' ', sort keys %{$self->{'accept_directives'}} )
  784.         ;
  785.         $self->whine(
  786.           $para->[1]{'start_line'},
  787.           "Unknown directive: $para->[0]"
  788.         );
  789.  
  790.         # And maybe treat it as text instead of just letting it go?
  791.         next;
  792.       }
  793.  
  794.       if($para_type =~ s/^\?//s) {
  795.         if(! @$curr_open) {  # usual case
  796.           DEBUG and print "Treating $para_type paragraph as such because stack is empty.\n";
  797.         } else {
  798.           my @fors = grep $_->[0] eq '=for', @$curr_open;
  799.           DEBUG > 1 and print "Containing fors: ",
  800.             join(',', map $_->[1]{'target'}, @fors), "\n";
  801.           
  802.           if(! @fors) {
  803.             DEBUG and print "Treating $para_type paragraph as such because stack has no =for's\n";
  804.             
  805.           #} elsif(grep $_->[1]{'~resolve'}, @fors) {
  806.           #} elsif(not grep !$_->[1]{'~resolve'}, @fors) {
  807.           } elsif( $fors[-1][1]{'~resolve'} ) {
  808.             # Look to the immediately containing for
  809.           
  810.             if($para_type eq 'Data') {
  811.               DEBUG and print "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
  812.               $para->[0] = 'Para';
  813.               $para_type = 'Plain';
  814.             } else {
  815.               DEBUG and print "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
  816.             }
  817.           } else {
  818.             DEBUG and print "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n";
  819.             $para->[0] = $para_type = 'Data';
  820.           }
  821.         }
  822.       }
  823.  
  824.       #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  825.       if($para_type eq 'Plain') {
  826.         $self->_ponder_Plain($para);
  827.       } elsif($para_type eq 'Verbatim') {
  828.         $self->_ponder_Verbatim($para);        
  829.       } elsif($para_type eq 'Data') {
  830.         $self->_ponder_Data($para);
  831.       } else {
  832.         die "\$para type is $para_type -- how did that happen?";
  833.         # Shouldn't happen.
  834.       }
  835.  
  836.       #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  837.       $para->[0] =~ s/^[~=]//s;
  838.  
  839.       DEBUG and print "\n", pretty($para), "\n";
  840.  
  841.       # traverse the treelet (which might well be just one string scalar)
  842.       $self->{'content_seen'} ||= 1;
  843.       $self->_traverse_treelet_bit(@$para);
  844.     }
  845.   }
  846.   
  847.   return;
  848. }
  849.  
  850. ###########################################################################
  851. # The sub-ponderers...
  852.  
  853.  
  854.  
  855. sub _ponder_for {
  856.   my ($self,$para,$curr_open,$paras) = @_;
  857.  
  858.   # Fake it out as a begin/end
  859.   my $target;
  860.  
  861.   if(grep $_->[1]{'~ignore'}, @$curr_open) {
  862.     DEBUG > 1 and print "Ignoring ignorable =for\n";
  863.     return 1;
  864.   }
  865.  
  866.   for(my $i = 2; $i < @$para; ++$i) {
  867.     if($para->[$i] =~ s/^\s*(\S+)\s*//s) {
  868.       $target = $1;
  869.       last;
  870.     }
  871.   }
  872.   unless(defined $target) {
  873.     $self->whine(
  874.       $para->[1]{'start_line'},
  875.       "=for without a target?"
  876.     );
  877.     return 1;
  878.   }
  879.   DEBUG > 1 and
  880.    print "Faking out a =for $target as a =begin $target / =end $target\n";
  881.   
  882.   $para->[0] = 'Data';
  883.   
  884.   unshift @$paras,
  885.     ['=begin',
  886.       {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
  887.       $target,
  888.     ],
  889.     $para,
  890.     ['=end',
  891.       {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
  892.       $target,
  893.     ],
  894.   ;
  895.   
  896.   return 1;
  897. }
  898.  
  899. sub _ponder_begin {
  900.   my ($self,$para,$curr_open,$paras) = @_;
  901.   my $content = join ' ', splice @$para, 2;
  902.   $content =~ s/^\s+//s;
  903.   $content =~ s/\s+$//s;
  904.   unless(length($content)) {
  905.     $self->whine(
  906.       $para->[1]{'start_line'},
  907.       "=begin without a target?"
  908.     );
  909.     DEBUG and print "Ignoring targetless =begin\n";
  910.     return 1;
  911.   }
  912.   
  913.   unless($content =~ m/^\S+$/s) {  # i.e., unless it's one word
  914.     $self->whine(
  915.       $para->[1]{'start_line'},
  916.       "'=begin' only takes one parameter, not several as in '=begin $content'"
  917.     );
  918.     DEBUG and print "Ignoring unintelligible =begin $content\n";
  919.     return 1;
  920.   }
  921.  
  922.  
  923.   $para->[1]{'target'} = $content;  # without any ':'
  924.  
  925.   $content =~ s/^:!/!:/s;
  926.   my $neg;  # whether this is a negation-match
  927.   $neg = 1        if $content =~ s/^!//s;
  928.   my $to_resolve;  # whether to process formatting codes
  929.   $to_resolve = 1 if $content =~ s/^://s;
  930.   
  931.   my $dont_ignore; # whether this target matches us
  932.   
  933.   foreach my $target_name (
  934.     split(',', $content, -1),
  935.     $neg ? () : '*'
  936.   ) {
  937.     DEBUG > 2 and
  938.      print " Considering whether =begin $content matches $target_name\n";
  939.     next unless $self->{'accept_targets'}{$target_name};
  940.     
  941.     DEBUG > 2 and
  942.      print "  It DOES match the acceptable target $target_name!\n";
  943.     $to_resolve = 1
  944.       if $self->{'accept_targets'}{$target_name} eq 'force_resolve';
  945.     $dont_ignore = 1;
  946.     $para->[1]{'target_matching'} = $target_name;
  947.     last; # stop looking at other target names
  948.   }
  949.  
  950.   if($neg) {
  951.     if( $dont_ignore ) {
  952.       $dont_ignore = '';
  953.       delete $para->[1]{'target_matching'};
  954.       DEBUG > 2 and print " But the leading ! means that this is a NON-match!\n";
  955.     } else {
  956.       $dont_ignore = 1;
  957.       $para->[1]{'target_matching'} = '!';
  958.       DEBUG > 2 and print " But the leading ! means that this IS a match!\n";
  959.     }
  960.   }
  961.  
  962.   $para->[0] = '=for';  # Just what we happen to call these, internally
  963.   $para->[1]{'~really'} ||= '=begin';
  964.   $para->[1]{'~ignore'}   = (! $dont_ignore) || 0;
  965.   $para->[1]{'~resolve'}  = $to_resolve || 0;
  966.  
  967.   DEBUG > 1 and print " Making note to ", $dont_ignore ? 'not ' : '',
  968.     "ignore contents of this region\n";
  969.   DEBUG > 1 and $dont_ignore and print " Making note to treat contents as ",
  970.     ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n";
  971.   DEBUG > 1 and print " (Stack now: ", $self->_dump_curr_open(), ")\n";
  972.  
  973.   push @$curr_open, $para;
  974.   if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) {
  975.     DEBUG > 1 and print "Ignoring ignorable =begin\n";
  976.   } else {
  977.     $self->{'content_seen'} ||= 1;
  978.     $self->_handle_element_start((my $scratch='for'), $para->[1]);
  979.   }
  980.  
  981.   return 1;
  982. }
  983.  
  984. sub _ponder_end {
  985.   my ($self,$para,$curr_open,$paras) = @_;
  986.   my $content = join ' ', splice @$para, 2;
  987.   $content =~ s/^\s+//s;
  988.   $content =~ s/\s+$//s;
  989.   DEBUG and print "Ogling '=end $content' directive\n";
  990.   
  991.   unless(length($content)) {
  992.     $self->whine(
  993.       $para->[1]{'start_line'},
  994.       "'=end' without a target?" . (
  995.         ( @$curr_open and $curr_open->[-1][0] eq '=for' )
  996.         ? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' )
  997.         : ''
  998.       )
  999.     );
  1000.     DEBUG and print "Ignoring targetless =end\n";
  1001.     return 1;
  1002.   }
  1003.   
  1004.   unless($content =~ m/^\S+$/) {  # i.e., unless it's one word
  1005.     $self->whine(
  1006.       $para->[1]{'start_line'},
  1007.       "'=end $content' is invalid.  (Stack: "
  1008.       . $self->_dump_curr_open() . ')'
  1009.     );
  1010.     DEBUG and print "Ignoring mistargetted =end $content\n";
  1011.     return 1;
  1012.   }
  1013.   
  1014.   unless(@$curr_open and $curr_open->[-1][0] eq '=for') {
  1015.     $self->whine(
  1016.       $para->[1]{'start_line'},
  1017.       "=end $content without matching =begin.  (Stack: "
  1018.       . $self->_dump_curr_open() . ')'
  1019.     );
  1020.     DEBUG and print "Ignoring mistargetted =end $content\n";
  1021.     return 1;
  1022.   }
  1023.   
  1024.   unless($content eq $curr_open->[-1][1]{'target'}) {
  1025.     $self->whine(
  1026.       $para->[1]{'start_line'},
  1027.       "=end $content doesn't match =begin " 
  1028.       . $curr_open->[-1][1]{'target'}
  1029.       . ".  (Stack: "
  1030.       . $self->_dump_curr_open() . ')'
  1031.     );
  1032.     DEBUG and print "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n";
  1033.     return 1;
  1034.   }
  1035.  
  1036.   # Else it's okay to close...
  1037.   if(grep $_->[1]{'~ignore'}, @$curr_open) {
  1038.     DEBUG > 1 and print "Not firing any event for this =end $content because in an ignored region\n";
  1039.     # And that may be because of this to-be-closed =for region, or some
  1040.     #  other one, but it doesn't matter.
  1041.   } else {
  1042.     $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'};
  1043.       # what's that for?
  1044.     
  1045.     $self->{'content_seen'} ||= 1;
  1046.     $self->_handle_element_end( my $scratch = 'for' );
  1047.   }
  1048.   DEBUG > 1 and print "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n";
  1049.   pop @$curr_open;
  1050.  
  1051.   return 1;
  1052. } 
  1053.  
  1054. sub _ponder_doc_end {
  1055.   my ($self,$para,$curr_open,$paras) = @_;
  1056.   if(@$curr_open) { # Deal with things left open
  1057.     DEBUG and print "Stack is nonempty at end-document: (",
  1058.       $self->_dump_curr_open(), ")\n";
  1059.       
  1060.     DEBUG > 9 and print "Stack: ", pretty($curr_open), "\n";
  1061.     unshift @$paras, $self->_closers_for_all_curr_open;
  1062.     # Make sure there is exactly one ~end in the parastack, at the end:
  1063.     @$paras = grep $_->[0] ne '~end', @$paras;
  1064.     push @$paras, $para, $para;
  1065.      # We need two -- once for the next cycle where we
  1066.      #  generate errata, and then another to be at the end
  1067.      #  when that loop back around to process the errata.
  1068.     return 1;
  1069.     
  1070.   } else {
  1071.     DEBUG and print "Okay, stack is empty now.\n";
  1072.   }
  1073.   
  1074.   # Try generating errata section, if applicable
  1075.   unless($self->{'~tried_gen_errata'}) {
  1076.     $self->{'~tried_gen_errata'} = 1;
  1077.     my @extras = $self->_gen_errata();
  1078.     if(@extras) {
  1079.       unshift @$paras, @extras;
  1080.       DEBUG and print "Generated errata... relooping...\n";
  1081.       return 1;  # I.e., loop around again to process these fake-o paragraphs
  1082.     }
  1083.   }
  1084.   
  1085.   splice @$paras; # Well, that's that for this paragraph buffer.
  1086.   DEBUG and print "Throwing end-document event.\n";
  1087.  
  1088.   $self->_handle_element_end( my $scratch = 'Document' );
  1089.   return 1; # Hasta la byebye
  1090. }
  1091.  
  1092. sub _ponder_pod {
  1093.   my ($self,$para,$curr_open,$paras) = @_;
  1094.   $self->whine(
  1095.     $para->[1]{'start_line'},
  1096.     "=pod directives shouldn't be over one line long!  Ignoring all "
  1097.      . (@$para - 2) . " lines of content"
  1098.   ) if @$para > 3;
  1099.   # Content is always ignored.
  1100.   return;
  1101. }
  1102.  
  1103. sub _ponder_over {
  1104.   my ($self,$para,$curr_open,$paras) = @_;
  1105.   return 1 unless @$paras;
  1106.   my $list_type;
  1107.  
  1108.   if($paras->[0][0] eq '=item') { # most common case
  1109.     $list_type = $self->_get_initial_item_type($paras->[0]);
  1110.  
  1111.   } elsif($paras->[0][0] eq '=back') {
  1112.     # Ignore empty lists.  TODO: make this an option?
  1113.     shift @$paras;
  1114.     return 1;
  1115.     
  1116.   } elsif($paras->[0][0] eq '~end') {
  1117.     $self->whine(
  1118.       $para->[1]{'start_line'},
  1119.       "=over is the last thing in the document?!"
  1120.     );
  1121.     return 1; # But feh, ignore it.
  1122.   } else {
  1123.     $list_type = 'block';
  1124.   }
  1125.   $para->[1]{'~type'} = $list_type;
  1126.   push @$curr_open, $para;
  1127.    # yes, we reuse the paragraph as a stack item
  1128.   
  1129.   my $content = join ' ', splice @$para, 2;
  1130.   my $overness;
  1131.   if($content =~ m/^\s*$/s) {
  1132.     $para->[1]{'indent'} = 4;
  1133.   } elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) {
  1134.     no integer;
  1135.     $para->[1]{'indent'} = $1;
  1136.     if($1 == 0) {
  1137.       $self->whine(
  1138.         $para->[1]{'start_line'},
  1139.         "Can't have a 0 in =over $content"
  1140.       );
  1141.       $para->[1]{'indent'} = 4;
  1142.     }
  1143.   } else {
  1144.     $self->whine(
  1145.       $para->[1]{'start_line'},
  1146.       "=over should be: '=over' or '=over positive_number'"
  1147.     );
  1148.     $para->[1]{'indent'} = 4;
  1149.   }
  1150.   DEBUG > 1 and print "=over found of type $list_type\n";
  1151.   
  1152.   $self->{'content_seen'} ||= 1;
  1153.   $self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]);
  1154.  
  1155.   return;
  1156. }
  1157.       
  1158. sub _ponder_back {
  1159.   my ($self,$para,$curr_open,$paras) = @_;
  1160.   # TODO: fire off </item-number> or </item-bullet> or </item-text> ??
  1161.  
  1162.   my $content = join ' ', splice @$para, 2;
  1163.   if($content =~ m/\S/) {
  1164.     $self->whine(
  1165.       $para->[1]{'start_line'},
  1166.       "=back doesn't take any parameters, but you said =back $content"
  1167.     );
  1168.   }
  1169.  
  1170.   if(@$curr_open and $curr_open->[-1][0] eq '=over') {
  1171.     DEBUG > 1 and print "=back happily closes matching =over\n";
  1172.     # Expected case: we're closing the most recently opened thing
  1173.     #my $over = pop @$curr_open;
  1174.     $self->{'content_seen'} ||= 1;
  1175.     $self->_handle_element_end( my $scratch =
  1176.       'over-' . ( (pop @$curr_open)->[1]{'~type'} )
  1177.     );
  1178.   } else {
  1179.     DEBUG > 1 and print "=back found without a matching =over.  Stack: (",
  1180.         join(', ', map $_->[0], @$curr_open), ").\n";
  1181.     $self->whine(
  1182.       $para->[1]{'start_line'},
  1183.       '=back without =over'
  1184.     );
  1185.     return 1; # and ignore it
  1186.   }
  1187. }
  1188.  
  1189. sub _ponder_item {
  1190.   my ($self,$para,$curr_open,$paras) = @_;
  1191.   my $over;
  1192.   unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') {
  1193.     $self->whine(
  1194.       $para->[1]{'start_line'},
  1195.       "'=item' outside of any '=over'"
  1196.     );
  1197.     unshift @$paras,
  1198.       ['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
  1199.       $para
  1200.     ;
  1201.     return 1;
  1202.   }
  1203.   
  1204.   
  1205.   my $over_type = $over->[1]{'~type'};
  1206.   
  1207.   if(!$over_type) {
  1208.     # Shouldn't happen1
  1209.     die "Typeless over in stack, starting at line "
  1210.      . $over->[1]{'start_line'};
  1211.  
  1212.   } elsif($over_type eq 'block') {
  1213.     unless($curr_open->[-1][1]{'~bitched_about'}) {
  1214.       $curr_open->[-1][1]{'~bitched_about'} = 1;
  1215.       $self->whine(
  1216.         $curr_open->[-1][1]{'start_line'},
  1217.         "You can't have =items (as at line "
  1218.         . $para->[1]{'start_line'}
  1219.         . ") unless the first thing after the =over is an =item"
  1220.       );
  1221.     }
  1222.     # Just turn it into a paragraph and reconsider it
  1223.     $para->[0] = '~Para';
  1224.     unshift @$paras, $para;
  1225.     return 1;
  1226.  
  1227.   } elsif($over_type eq 'text') {
  1228.     my $item_type = $self->_get_item_type($para);
  1229.       # That kills the content of the item if it's a number or bullet.
  1230.     DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
  1231.     
  1232.     if($item_type eq 'text') {
  1233.       # Nothing special needs doing for 'text'
  1234.     } elsif($item_type eq 'number' or $item_type eq 'bullet') {
  1235.       die "Unknown item type $item_type"
  1236.        unless $item_type eq 'number' or $item_type eq 'bullet';
  1237.       # Undo our clobbering:
  1238.       push @$para, $para->[1]{'~orig_content'};
  1239.       delete $para->[1]{'number'};
  1240.        # Only a PROPER item-number element is allowed
  1241.        #  to have a number attribute.
  1242.     } else {
  1243.       die "Unhandled item type $item_type"; # should never happen
  1244.     }
  1245.     
  1246.     # =item-text thingies don't need any assimilation, it seems.
  1247.  
  1248.   } elsif($over_type eq 'number') {
  1249.     my $item_type = $self->_get_item_type($para);
  1250.       # That kills the content of the item if it's a number or bullet.
  1251.     DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
  1252.     
  1253.     my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
  1254.     
  1255.     if($item_type eq 'bullet') {
  1256.       # Hm, it's not numeric.  Correct for this.
  1257.       $para->[1]{'number'} = $expected_value;
  1258.       $self->whine(
  1259.         $para->[1]{'start_line'},
  1260.         "Expected '=item $expected_value'"
  1261.       );
  1262.       push @$para, $para->[1]{'~orig_content'};
  1263.         # restore the bullet, blocking the assimilation of next para
  1264.  
  1265.     } elsif($item_type eq 'text') {
  1266.       # Hm, it's not numeric.  Correct for this.
  1267.       $para->[1]{'number'} = $expected_value;
  1268.       $self->whine(
  1269.         $para->[1]{'start_line'},
  1270.         "Expected '=item $expected_value'"
  1271.       );
  1272.       # Text content will still be there and will block next ~Para
  1273.  
  1274.     } elsif($item_type ne 'number') {
  1275.       die "Unknown item type $item_type"; # should never happen
  1276.  
  1277.     } elsif($expected_value == $para->[1]{'number'}) {
  1278.       DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n";
  1279.       
  1280.     } else {
  1281.       DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'},
  1282.        " instead of the expected value of $expected_value\n";
  1283.       $self->whine(
  1284.         $para->[1]{'start_line'},
  1285.         "You have '=item " . $para->[1]{'number'} .
  1286.         "' instead of the expected '=item $expected_value'"
  1287.       );
  1288.       $para->[1]{'number'} = $expected_value;  # correcting!!
  1289.     }
  1290.       
  1291.     if(@$para == 2) {
  1292.       # For the cases where we /didn't/ push to @$para
  1293.       if($paras->[0][0] eq '~Para') {
  1294.         DEBUG and print "Assimilating following ~Para content into $over_type item\n";
  1295.         push @$para, splice @{shift @$paras},2;
  1296.       } else {
  1297.         DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
  1298.         push @$para, '';  # Just so it's not contentless
  1299.       }
  1300.     }
  1301.  
  1302.  
  1303.   } elsif($over_type eq 'bullet') {
  1304.     my $item_type = $self->_get_item_type($para);
  1305.       # That kills the content of the item if it's a number or bullet.
  1306.     DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
  1307.     
  1308.     if($item_type eq 'bullet') {
  1309.       # as expected!
  1310.  
  1311.       if( $para->[1]{'~_freaky_para_hack'} ) {
  1312.         DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n";
  1313.         push @$para, delete $para->[1]{'~_freaky_para_hack'};
  1314.       }
  1315.  
  1316.     } elsif($item_type eq 'number') {
  1317.       $self->whine(
  1318.         $para->[1]{'start_line'},
  1319.         "Expected '=item *'"
  1320.       );
  1321.       push @$para, $para->[1]{'~orig_content'};
  1322.        # and block assimilation of the next paragraph
  1323.       delete $para->[1]{'number'};
  1324.        # Only a PROPER item-number element is allowed
  1325.        #  to have a number attribute.
  1326.     } elsif($item_type eq 'text') {
  1327.       $self->whine(
  1328.         $para->[1]{'start_line'},
  1329.         "Expected '=item *'"
  1330.       );
  1331.        # But doesn't need processing.  But it'll block assimilation
  1332.        #  of the next para.
  1333.     } else {
  1334.       die "Unhandled item type $item_type"; # should never happen
  1335.     }
  1336.  
  1337.     if(@$para == 2) {
  1338.       # For the cases where we /didn't/ push to @$para
  1339.       if($paras->[0][0] eq '~Para') {
  1340.         DEBUG and print "Assimilating following ~Para content into $over_type item\n";
  1341.         push @$para, splice @{shift @$paras},2;
  1342.       } else {
  1343.         DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
  1344.         push @$para, '';  # Just so it's not contentless
  1345.       }
  1346.     }
  1347.  
  1348.   } else {
  1349.     die "Unhandled =over type \"$over_type\"?";
  1350.     # Shouldn't happen!
  1351.   }
  1352.   $para->[0] .= '-' . $over_type;
  1353.  
  1354.   return;
  1355. }
  1356.  
  1357. sub _ponder_Plain {
  1358.   my ($self,$para) = @_;
  1359.   DEBUG and print " giving plain treatment...\n";
  1360.   unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' )
  1361.     or $para->[1]{'~cooked'}
  1362.   ) {
  1363.     push @$para,
  1364.     @{$self->_make_treelet(
  1365.       join("\n", splice(@$para, 2)),
  1366.       $para->[1]{'start_line'}
  1367.     )};
  1368.   }
  1369.   # Empty paragraphs don't need a treelet for any reason I can see.
  1370.   # And precooked paragraphs already have a treelet.
  1371.   return;
  1372. }
  1373.  
  1374. sub _ponder_Verbatim {
  1375.   my ($self,$para) = @_;
  1376.   DEBUG and print " giving verbatim treatment...\n";
  1377.  
  1378.   $para->[1]{'xml:space'} = 'preserve';
  1379.   for(my $i = 2; $i < @$para; $i++) {
  1380.     foreach my $line ($para->[$i]) { # just for aliasing
  1381.       while( $line =~
  1382.         # Sort of adapted from Text::Tabs -- yes, it's hardwired in that
  1383.         # tabs are at every EIGHTH column.  For portability, it has to be
  1384.         # one setting everywhere, and 8th wins.
  1385.         s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e
  1386.       ) {}
  1387.  
  1388.       # TODO: whinge about (or otherwise treat) unindented or overlong lines
  1389.  
  1390.     }
  1391.   }
  1392.   
  1393.   # Now the VerbatimFormatted hoodoo...
  1394.   if( $self->{'accept_codes'} and
  1395.       $self->{'accept_codes'}{'VerbatimFormatted'}
  1396.   ) {
  1397.     while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para }
  1398.      # Kill any number of terminal newlines
  1399.     $self->_verbatim_format($para);
  1400.   } elsif ($self->{'codes_in_verbatim'}) {
  1401.     push @$para,
  1402.     @{$self->_make_treelet(
  1403.       join("\n", splice(@$para, 2)),
  1404.       $para->[1]{'start_line'}, $para->[1]{'xml:space'}
  1405.     )};
  1406.     $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
  1407.   } else {
  1408.     push @$para, join "\n", splice(@$para, 2) if @$para > 3;
  1409.     $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
  1410.   }
  1411.   return;
  1412. }
  1413.  
  1414. sub _ponder_Data {
  1415.   my ($self,$para) = @_;
  1416.   DEBUG and print " giving data treatment...\n";
  1417.   $para->[1]{'xml:space'} = 'preserve';
  1418.   push @$para, join "\n", splice(@$para, 2) if @$para > 3;
  1419.   return;
  1420. }
  1421.  
  1422.  
  1423.  
  1424.  
  1425. ###########################################################################
  1426.  
  1427. sub _traverse_treelet_bit {  # for use only by the routine above
  1428.   my($self, $name) = splice @_,0,2;
  1429.  
  1430.   my $scratch;
  1431.   $self->_handle_element_start(($scratch=$name), shift @_);
  1432.   
  1433.   foreach my $x (@_) {
  1434.     if(ref($x)) {
  1435.       &_traverse_treelet_bit($self, @$x);
  1436.     } else {
  1437.       $self->_handle_text($x);
  1438.     }
  1439.   }
  1440.   
  1441.   $self->_handle_element_end($scratch=$name);
  1442.   return;
  1443. }
  1444.  
  1445. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1446.  
  1447. sub _closers_for_all_curr_open {
  1448.   my $self = $_[0];
  1449.   my @closers;
  1450.   foreach my $still_open (@{  $self->{'curr_open'} || return  }) {
  1451.     my @copy = @$still_open;
  1452.     $copy[1] = {%{ $copy[1] }};
  1453.     #$copy[1]{'start_line'} = -1;
  1454.     if($copy[0] eq '=for') {
  1455.       $copy[0] = '=end';
  1456.     } elsif($copy[0] eq '=over') {
  1457.       $copy[0] = '=back';
  1458.     } else {
  1459.       die "I don't know how to auto-close an open $copy[0] region";
  1460.     }
  1461.  
  1462.     unless( @copy > 2 ) {
  1463.       push @copy, $copy[1]{'target'};
  1464.       $copy[-1] = '' unless defined $copy[-1];
  1465.        # since =over's don't have targets
  1466.     }
  1467.     
  1468.     DEBUG and print "Queuing up fake-o event: ", pretty(\@copy), "\n";
  1469.     unshift @closers, \@copy;
  1470.   }
  1471.   return @closers;
  1472. }
  1473.  
  1474. #--------------------------------------------------------------------------
  1475.  
  1476. sub _verbatim_format {
  1477.   my($it, $p) = @_;
  1478.   
  1479.   my $formatting;
  1480.  
  1481.   for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines
  1482.     DEBUG and print "_verbatim_format appends a newline to $i: $p->[$i]\n";
  1483.     $p->[$i] .= "\n";
  1484.      # Unlike with simple Verbatim blocks, we don't end up just doing
  1485.      # a join("\n", ...) on the contents, so we have to append a
  1486.      # newline to ever line, and then nix the last one later.
  1487.   }
  1488.  
  1489.   if( DEBUG > 4 ) {
  1490.     print "<<\n";
  1491.     for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines
  1492.       print "_verbatim_format $i: $p->[$i]";
  1493.     }
  1494.     print ">>\n";
  1495.   }
  1496.  
  1497.   for(my $i = $#$p; $i > 2; $i--) {
  1498.     # work backwards over the lines, except the first (#2)
  1499.     
  1500.     #next unless $p->[$i]   =~ m{^#:([ \^\/\%]*)\n?$}s
  1501.     #        and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s;
  1502.      # look at a formatty line preceding a nonformatty one
  1503.     DEBUG > 5 and print "Scrutinizing line $i: $$p[$i]\n";
  1504.     if($p->[$i]   =~ m{^#:([ \^\/\%]*)\n?$}s) {
  1505.       DEBUG > 5 and print "  It's a formatty line.  ",
  1506.        "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n";
  1507.       
  1508.       if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) {
  1509.         DEBUG > 5 and print "  Previous line is formatty!  Skipping this one.\n";
  1510.         next;
  1511.       } else {
  1512.         DEBUG > 5 and print "  Previous line is non-formatty!  Yay!\n";
  1513.       }
  1514.     } else {
  1515.       DEBUG > 5 and print "  It's not a formatty line.  Ignoring\n";
  1516.       next;
  1517.     }
  1518.  
  1519.     # A formatty line has to have #: in the first two columns, and uses
  1520.     # "^" to mean bold, "/" to mean underline, and "%" to mean bold italic.
  1521.     # Example:
  1522.     #   What do you want?  i like pie. [or whatever]
  1523.     # #:^^^^^^^^^^^^^^^^^              /////////////         
  1524.     
  1525.  
  1526.     DEBUG > 4 and print "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n";
  1527.     
  1528.     $formatting = '  ' . $1;
  1529.     $formatting =~ s/\s+$//s; # nix trailing whitespace
  1530.     unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op
  1531.       splice @$p,$i,1; # remove this line
  1532.       $i--; # don't consider next line
  1533.       next;
  1534.     }
  1535.  
  1536.     if( length($formatting) >= length($p->[$i-1]) ) {
  1537.       $formatting = substr($formatting, 0, length($p->[$i-1]) - 1) . ' ';
  1538.     } else {
  1539.       $formatting .= ' ' x (length($p->[$i-1]) - length($formatting));
  1540.     }
  1541.     # Make $formatting and the previous line be exactly the same length,
  1542.     # with $formatting having a " " as the last character.
  1543.  
  1544.     DEBUG > 4 and print "Formatting <$formatting>    on <", $p->[$i-1], ">\n";
  1545.  
  1546.  
  1547.     my @new_line;
  1548.     while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) {
  1549.       #print "Format matches $1\n";
  1550.  
  1551.       if($2) {
  1552.         #print "SKIPPING <$2>\n";
  1553.         push @new_line,
  1554.           substr($p->[$i-1], pos($formatting)-length($1), length($1));
  1555.       } else {
  1556.         #print "SNARING $+\n";
  1557.         push @new_line, [
  1558.           (
  1559.             $3 ? 'VerbatimB'  :
  1560.             $4 ? 'VerbatimI'  :
  1561.             $5 ? 'VerbatimBI' : die("Should never get called")
  1562.           ), {},
  1563.           substr($p->[$i-1], pos($formatting)-length($1), length($1))
  1564.         ];
  1565.         #print "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n";
  1566.       }
  1567.     }
  1568.     my @nixed =    
  1569.       splice @$p, $i-1, 2, @new_line; # replace myself and the next line
  1570.     DEBUG > 10 and print "Nixed count: ", scalar(@nixed), "\n";
  1571.     
  1572.     DEBUG > 6 and print "New version of the above line is these tokens (",
  1573.       scalar(@new_line), "):",
  1574.       map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n";
  1575.     $i--; # So the next line we scrutinize is the line before the one
  1576.           #  that we just went and formatted
  1577.   }
  1578.  
  1579.   $p->[0] = 'VerbatimFormatted';
  1580.  
  1581.   # Collapse adjacent text nodes, just for kicks.
  1582.   for( my $i = 2; $i > $#$p; $i++ ) { # work forwards over the tokens except for the last
  1583.     if( !ref($p->[$i]) and !ref($p->[$i + 1]) ) {
  1584.       DEBUG > 5 and print "_verbatim_format merges {$p->[$i]} and {$p->[$i+1]}\n";
  1585.       $p->[$i] .= splice @$p, $i+1, 1; # merge
  1586.       --$i;  # and back up
  1587.     }
  1588.   }
  1589.  
  1590.   # Now look for the last text token, and remove the terminal newline
  1591.   for( my $i = $#$p; $i >= 2; $i-- ) {
  1592.     # work backwards over the tokens, even the first
  1593.     if( !ref($p->[$i]) ) {
  1594.       if($p->[$i] =~ s/\n$//s) {
  1595.         DEBUG > 5 and print "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n";
  1596.       } else {
  1597.         DEBUG > 5 and print
  1598.          "No terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]} !?\n";
  1599.       }
  1600.       last; # we only want the next one
  1601.     }
  1602.   }
  1603.  
  1604.   return;
  1605. }
  1606.  
  1607.  
  1608. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1609.  
  1610.  
  1611. sub _treelet_from_formatting_codes {
  1612.   # Given a paragraph, returns a treelet.  Full of scary tokenizing code.
  1613.   #  Like [ '~Top', {'start_line' => $start_line},
  1614.   #            "I like ",
  1615.   #            [ 'B', {}, "pie" ],
  1616.   #            "!"
  1617.   #       ]
  1618.   
  1619.   my($self, $para, $start_line, $preserve_space) = @_;
  1620.   
  1621.   my $treelet = ['~Top', {'start_line' => $start_line},];
  1622.   
  1623.   unless ($preserve_space || $self->{'preserve_whitespace'}) {
  1624.     $para =~ s/\.  /\.\xA0 /g if $self->{'fullstop_space_harden'};
  1625.   
  1626.     $para =~ s/\s+/ /g; # collapse and trim all whitespace first.
  1627.     $para =~ s/ $//;
  1628.     $para =~ s/^ //;
  1629.   }
  1630.   
  1631.   # Only apparent problem the above code is that N<<  >> turns into
  1632.   # N<< >>.  But then, word wrapping does that too!  So don't do that!
  1633.   
  1634.   my @stack;
  1635.   my @lineage = ($treelet);
  1636.  
  1637.   DEBUG > 4 and print "Paragraph:\n$para\n\n";
  1638.  
  1639.   # Here begins our frightening tokenizer RE.  The following regex matches
  1640.   # text in four main parts:
  1641.   #
  1642.   #  * Start-codes.  The first alternative matches C< or C<<, the latter
  1643.   #    followed by some whitespace.  $1 will hold the entire start code
  1644.   #    (including any space following a multiple-angle-bracket delimiter),
  1645.   #    and $2 will hold only the additional brackets past the first in a
  1646.   #    multiple-bracket delimiter.  length($2) + 1 will be the number of
  1647.   #    closing brackets we have to find.
  1648.   #
  1649.   #  * Closing brackets.  Match some amount of whitespace followed by
  1650.   #    multiple close brackets.  The logic to see if this closes anything
  1651.   #    is down below.  Note that in order to parse C<<  >> correctly, we
  1652.   #    have to use look-behind (?<=\s\s), since the match of the starting
  1653.   #    code will have consumed the whitespace.
  1654.   #
  1655.   #  * A single closing bracket, to close a simple code like C<>.
  1656.   #
  1657.   #  * Something that isn't a start or end code.  We have to be careful
  1658.   #    about accepting whitespace, since perlpodspec says that any whitespace
  1659.   #    before a multiple-bracket closing delimiter should be ignored.
  1660.   #
  1661.   while($para =~
  1662.     m/\G
  1663.       (?:
  1664.         # Match starting codes, including the whitespace following a
  1665.         # multiple-delimiter start code.  $1 gets the whole start code and
  1666.         # $2 gets all but one of the <s in the multiple-bracket case.
  1667.         ([A-Z]<(?:(<+)\s+)?)
  1668.         |
  1669.         # Match multiple-bracket end codes.  $3 gets the whitespace that
  1670.         # should be discarded before an end bracket but kept in other cases
  1671.         # and $4 gets the end brackets themselves.
  1672.         (\s+|(?<=\s\s))(>{2,})
  1673.         |
  1674.         (\s?>)          # $5: simple end-codes
  1675.         |
  1676.         (               # $6: stuff containing no start-codes or end-codes
  1677.           (?:
  1678.             [^A-Z\s>]
  1679.             |
  1680.             (?:
  1681.               [A-Z](?!<)
  1682.             )
  1683.             |
  1684.             (?:
  1685.               \s(?!\s*>)
  1686.             )
  1687.           )+
  1688.         )
  1689.       )
  1690.     /xgo
  1691.   ) {
  1692.     DEBUG > 4 and print "\nParagraphic tokenstack = (@stack)\n";
  1693.     if(defined $1) {
  1694.       if(defined $2) {
  1695.         DEBUG > 3 and print "Found complex start-text code \"$1\"\n";
  1696.         push @stack, length($2) + 1; 
  1697.           # length of the necessary complex end-code string
  1698.       } else {
  1699.         DEBUG > 3 and print "Found simple start-text code \"$1\"\n";
  1700.         push @stack, 0;  # signal that we're looking for simple
  1701.       }
  1702.       push @lineage, [ substr($1,0,1), {}, ];  # new node object
  1703.       push @{ $lineage[-2] }, $lineage[-1];
  1704.       
  1705.     } elsif(defined $4) {
  1706.       DEBUG > 3 and print "Found apparent complex end-text code \"$3$4\"\n";
  1707.       # This is where it gets messy...
  1708.       if(! @stack) {
  1709.         # We saw " >>>>" but needed nothing.  This is ALL just stuff then.
  1710.         DEBUG > 4 and print " But it's really just stuff.\n";
  1711.         push @{ $lineage[-1] }, $3, $4;
  1712.         next;
  1713.       } elsif(!$stack[-1]) {
  1714.         # We saw " >>>>" but needed only ">".  Back pos up.
  1715.         DEBUG > 4 and print " And that's more than we needed to close simple.\n";
  1716.         push @{ $lineage[-1] }, $3; # That was a for-real space, too.
  1717.         pos($para) = pos($para) - length($4) + 1;
  1718.       } elsif($stack[-1] == length($4)) {
  1719.         # We found " >>>>", and it was exactly what we needed.  Commonest case.
  1720.         DEBUG > 4 and print " And that's exactly what we needed to close complex.\n";
  1721.       } elsif($stack[-1] < length($4)) {
  1722.         # We saw " >>>>" but needed only " >>".  Back pos up.
  1723.         DEBUG > 4 and print " And that's more than we needed to close complex.\n";
  1724.         pos($para) = pos($para) - length($4) + $stack[-1];
  1725.       } else {
  1726.         # We saw " >>>>" but needed " >>>>>>".  So this is all just stuff!
  1727.         DEBUG > 4 and print " But it's really just stuff, because we needed more.\n";
  1728.         push @{ $lineage[-1] }, $3, $4;
  1729.         next;
  1730.       }
  1731.       #print "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n";
  1732.  
  1733.       push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
  1734.       # Keep the element from being childless
  1735.       
  1736.       pop @stack;
  1737.       pop @lineage;
  1738.       
  1739.     } elsif(defined $5) {
  1740.       DEBUG > 3 and print "Found apparent simple end-text code \"$4\"\n";
  1741.  
  1742.       if(@stack and ! $stack[-1]) {
  1743.         # We're indeed expecting a simple end-code
  1744.         DEBUG > 4 and print " It's indeed an end-code.\n";
  1745.  
  1746.         if(length($5) == 2) { # There was a space there: " >"
  1747.           push @{ $lineage[-1] }, ' ';
  1748.         } elsif( 2 == @{ $lineage[-1] } ) { # Closing a childless element
  1749.           push @{ $lineage[-1] }, ''; # keep it from being really childless
  1750.         }
  1751.  
  1752.         pop @stack;
  1753.         pop @lineage;
  1754.       } else {
  1755.         DEBUG > 4 and print " It's just stuff.\n";
  1756.         push @{ $lineage[-1] }, $5;
  1757.       }
  1758.  
  1759.     } elsif(defined $6) {
  1760.       DEBUG > 3 and print "Found stuff \"$6\"\n";
  1761.       push @{ $lineage[-1] }, $6;
  1762.       
  1763.     } else {
  1764.       # should never ever ever ever happen
  1765.       DEBUG and print "AYYAYAAAAA at line ", __LINE__, "\n";
  1766.       die "SPORK 512512!";
  1767.     }
  1768.   }
  1769.  
  1770.   if(@stack) { # Uhoh, some sequences weren't closed.
  1771.     my $x= "...";
  1772.     while(@stack) {
  1773.       push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
  1774.       # Hmmmmm!
  1775.  
  1776.       my $code         = (pop @lineage)->[0];
  1777.       my $ender_length =  pop @stack;
  1778.       if($ender_length) {
  1779.         --$ender_length;
  1780.         $x = $code . ("<" x $ender_length) . " $x " . (">" x $ender_length);
  1781.       } else {
  1782.         $x = $code . "<$x>";
  1783.       }
  1784.     }
  1785.     DEBUG > 1 and print "Unterminated $x sequence\n";
  1786.     $self->whine($start_line,
  1787.       "Unterminated $x sequence",
  1788.     );
  1789.   }
  1790.   
  1791.   return $treelet;
  1792. }
  1793.  
  1794. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1795.  
  1796. sub text_content_of_treelet {  # method: $parser->text_content_of_treelet($lol)
  1797.   return stringify_lol($_[1]);
  1798. }
  1799.  
  1800. sub stringify_lol {  # function: stringify_lol($lol)
  1801.   my $string_form = '';
  1802.   _stringify_lol( $_[0] => \$string_form );
  1803.   return $string_form;
  1804. }
  1805.  
  1806. sub _stringify_lol {  # the real recursor
  1807.   my($lol, $to) = @_;
  1808.   use UNIVERSAL ();
  1809.   for(my $i = 2; $i < @$lol; ++$i) {
  1810.     if( ref($lol->[$i] || '') and UNIVERSAL::isa($lol->[$i], 'ARRAY') ) {
  1811.       _stringify_lol( $lol->[$i], $to);  # recurse!
  1812.     } else {
  1813.       $$to .= $lol->[$i];
  1814.     }
  1815.   }
  1816.   return;
  1817. }
  1818.  
  1819. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1820.  
  1821. sub _dump_curr_open { # return a string representation of the stack
  1822.   my $curr_open = $_[0]{'curr_open'};
  1823.  
  1824.   return '[empty]' unless @$curr_open;
  1825.   return join '; ',
  1826.     map {;
  1827.            ($_->[0] eq '=for')
  1828.              ? ( ($_->[1]{'~really'} || '=over')
  1829.                . ' ' . $_->[1]{'target'})
  1830.              : $_->[0]
  1831.         }
  1832.     @$curr_open
  1833.   ;
  1834. }
  1835.  
  1836. ###########################################################################
  1837. my %pretty_form = (
  1838.   "\a" => '\a', # ding!
  1839.   "\b" => '\b', # BS
  1840.   "\e" => '\e', # ESC
  1841.   "\f" => '\f', # FF
  1842.   "\t" => '\t', # tab
  1843.   "\cm" => '\cm',
  1844.   "\cj" => '\cj',
  1845.   "\n" => '\n', # probably overrides one of either \cm or \cj
  1846.   '"' => '\"',
  1847.   '\\' => '\\\\',
  1848.   '$' => '\\$',
  1849.   '@' => '\\@',
  1850.   '%' => '\\%',
  1851.   '#' => '\\#',
  1852. );
  1853.  
  1854. sub pretty { # adopted from Class::Classless
  1855.   # Not the most brilliant routine, but passable.
  1856.   # Don't give it a cyclic data structure!
  1857.   my @stuff = @_; # copy
  1858.   my $x;
  1859.   my $out =
  1860.     # join ",\n" .
  1861.     join ", ",
  1862.     map {;
  1863.     if(!defined($_)) {
  1864.       "undef";
  1865.     } elsif(ref($_) eq 'ARRAY' or ref($_) eq 'Pod::Simple::LinkSection') {
  1866.       $x = "[ " . pretty(@$_) . " ]" ;
  1867.       $x;
  1868.     } elsif(ref($_) eq 'SCALAR') {
  1869.       $x = "\\" . pretty($$_) ;
  1870.       $x;
  1871.     } elsif(ref($_) eq 'HASH') {
  1872.       my $hr = $_;
  1873.       $x = "{" . join(", ",
  1874.         map(pretty($_) . '=>' . pretty($hr->{$_}),
  1875.             sort keys %$hr ) ) . "}" ;
  1876.       $x;
  1877.     } elsif(!length($_)) { q{''} # empty string
  1878.     } elsif(
  1879.       $_ eq '0' # very common case
  1880.       or(
  1881.          m/^-?(?:[123456789]\d*|0)(?:\.\d+)?$/s
  1882.          and $_ ne '-0' # the strange case that that RE lets thru
  1883.       )
  1884.     ) { $_;
  1885.     } else {
  1886.       if( chr(65) eq 'A' ) {
  1887.         s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
  1888.          #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
  1889.          <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
  1890.       } else {
  1891.         # We're in some crazy non-ASCII world!
  1892.         s<([^abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])>
  1893.          #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
  1894.          <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
  1895.       }
  1896.       qq{"$_"};
  1897.     }
  1898.   } @stuff;
  1899.   # $out =~ s/\n */ /g if length($out) < 75;
  1900.   return $out;
  1901. }
  1902.  
  1903. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1904.  
  1905. # A rather unsubtle method of blowing away all the state information
  1906. # from a parser object so it can be reused. Provided as a utility for
  1907. # backward compatibilty in Pod::Man, etc. but not recommended for
  1908. # general use.
  1909.  
  1910. sub reinit {
  1911.   my $self = shift;
  1912.   foreach (qw(source_dead source_filename doc_has_started
  1913. start_of_pod_block content_seen last_was_blank paras curr_open
  1914. line_count pod_para_count in_pod ~tried_gen_errata errata errors_seen
  1915. Title)) {
  1916.  
  1917.     delete $self->{$_};
  1918.   }
  1919. }
  1920.  
  1921. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1922. 1;
  1923.  
  1924.